;;;;;; core.scm - Scheme Core Language module.    -*- Mode: Scheme -*-
;;;;;; Author: Erik Silkensen <silkense@colorado.edu>
;;;;;; Version: 12 Aug 2009

#lang scheme

(require "parser.scm")

;;; This module provides procedures for testing whether or not a datum
;;; object is one of the core special forms of the Scheme language. In
;;; addition, some selector procedures are provided for accessing parts of
;;; a datum object.

;;; The core language is begin, define, if, lambda, quote, and set!.
;;; We also include procedures for define-syntax and syntax-rules.

(provide
 begin-datum?
 define-datum?
 define-syntax-datum?
 define-value
 define-variable
 ellipses-datum?
 if-datum?
 if-test
 if-consequent
 if-alternate
 lambda-datum?
 lambda-parameters
 lambda-body
 lambda-arity
 quote-datum
 quote-datum?
 set!-datum?
 set!-variable
 set!-value
 syntax-rules-datum?
 syntax-rules-literals
 syntax-rules-clauses
 unquote-datum?
 unquote-splicing-datum?)

(define (begin-datum? datum)
  (and (list-datum? datum)
       (let ((val (value-datum datum)))
         (and (>= (length val) 2)
              (symbol-datum? (car val))
              (string=? "begin" (value-datum (car val)))))))

(define (define-datum? datum)
  (and (list-datum? datum)
       (let ((val (value-datum datum)))
         (and (= 3 (length val))
              (symbol-datum? (car val))
              (string=? "_define" (value-datum (car val)))
              (symbol-datum? (cadr val))))))

(define (define-syntax-datum? datum)
  (and (list-datum? datum)
       (let ((val (value-datum datum)))
         (and (= 3 (length val))
              (symbol-datum? (car val))
              (string=? "define-syntax" (value-datum (car val)))
              (symbol-datum? (cadr val))))))

(define (define-variable datum)
  (cadr (value-datum datum)))

(define (define-value datum)
  (caddr (value-datum datum)))

(define (ellipses-datum? datum)
  (and (symbol-datum? datum)
       (string=? "..." (value-datum datum))))

(define (if-datum? datum)
  (and (list-datum? datum)
       (let ((val (value-datum datum)))
         (and (or (= 3 (length val))
                  (= 4 (length val)))
              (symbol-datum? (car val))
              (string=? "if" (value-datum (car val)))))))
  
(define (if-test datum)
  (cadr (value-datum datum)))

(define (if-consequent datum)
  (caddr (value-datum datum)))

(define (if-alternate datum)
  (let ((val (value-datum datum)))
    (if (= 3 (length val))
        (make-symbol-datum "#f" (position-datum datum))
        (cadddr val))))

(define (lambda-datum? datum)
  (and (list-datum? datum)
       (let ((val (value-datum datum)))
         (and (>= (length val) 3)
              (symbol-datum? (car val))
              (string=? "lambda" (value-datum (car val)))
              (let ((params (lambda-parameters datum)))
                (or (lambda-parameters? params)
                    (syntax-error params)))))))

(define (lambda-parameters? datum)
  (cond ((pair-datum? datum)
         (let ((val (value-datum datum)))
           (and (symbol-datum? (car val))
                (symbol-datum? (cdr val))
                (not (equal?-datum (car val) (cdr val))))))
        ((any-list-datum? datum)
         (and (let* ((val (value-datum (if (list-datum? datum)
                                           datum
                                           (flatten-dotted-datum datum))))
                     (vals (map value-datum val)))
                (andmap symbol-datum? val)
                (= (length val) (length (remove-duplicates vals))))))
        (else (symbol-datum? datum))))

(define (lambda-parameters datum)
  (cadr (value-datum datum)))

(define (lambda-body datum)
  (cddr (value-datum datum)))

(define (lambda-arity datum)
  (let ((params (lambda-parameters datum)))
    (cond ((pair-datum? params)
           (cons 1 'MAX-VALUE))
          ((symbol-datum? params)
           (cons 0 'MAX-VALUE))
          ((list-datum? params)
           (let ((arity (length (value-datum params))))
             (cons arity arity)))
          ((dotted-list-datum? params)
           (cons (length (value-datum params)) 'MAX-VALUE)))))

(define (quote-datum? datum)
  (<quote>-datum? datum "quote"))

(define (quote-datum datum)
  (cadr (value-datum datum)))

(define (set!-datum? datum)
  (and (list-datum? datum)
       (let ((val (value-datum datum)))
         (and (= 3 (length val))
              (symbol-datum? (car val))
              (string=? "set!" (value-datum (car val)))
              (symbol-datum? (set!-variable datum))))))

(define (set!-variable datum)
  (cadr (value-datum datum)))

(define (set!-value datum)
  (caddr (value-datum datum)))

(define (unquote-datum? datum)
  (<quote>-datum? datum "unquote"))

(define (unquote-splicing-datum? datum)
  (<quote>-datum? datum "unquote-splicing"))

(define (<quote>-datum? datum <quote>)
  (and (list-datum? datum)
       (let ((val (value-datum datum)))
         (and (= 2 (length val))
              (symbol-datum? (car val))
              (equal? <quote> (value-datum (car val)))))))

(define (syntax-rules-datum? datum)
  (and (list-datum? datum)
       (let ((val (value-datum datum)))
         (and (<= 3 (length val))
              (symbol-datum? (car val))
              (string=? "syntax-rules" (value-datum (car val)))
              (or (syntax-rules-literals? (syntax-rules-literals datum))
                  (syntax-error (syntax-rules-literals datum)))
              (or (syntax-rules-clauses? (syntax-rules-clauses datum))
                  (syntax-error (syntax-rules-clauses datum)))))))

(define (syntax-rules-clauses? datum) #t)

(define (syntax-rules-literals? datum)
  (and (list-datum? datum)
       (let* ((val (value-datum datum))
              (vals (map value-datum val)))
         (andmap symbol-datum? val)
         (= (length val) (length (remove-duplicates vals)))
         (not (member "..." vals)))))

(define (syntax-rules-clauses datum)
  (cddr (value-datum datum)))

(define (syntax-rules-literals datum)
  (cadr (value-datum datum)))
